home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / amok_lha / amok77.lha / GadToolsSupport / GadToolsSupport.mod < prev    next >
Text File  |  1993-08-15  |  16KB  |  441 lines
  1. (****************************************************************************
  2. :Program.       GadToolsSupport.mod
  3. :Contents.      Routines for easy gadget and menu-handling with 2.0 GadTools
  4. :Author.        Richard Günther [gvm]
  5. :Address.       HeilbronnerStr.267, 7410 Reutlingen
  6. :Phone.         07121/66432
  7. :Copyright.     Freeware
  8. :Language.      Oberon
  9. :Translator.    AmigaOberon v2.14d
  10. :History.       V1.0 [gvm] 26-Apr-92  first implementation
  11. :History.       V1.1 [gvm] 07-July-92 added menu support, new module name
  12. :Imports.       ExecLists [gvm]
  13. :Bugs.          Gadget.userData is used by this module, OS2.0 required
  14. ****************************************************************************)
  15.  
  16.  
  17. MODULE GadToolsSupport ;
  18.  
  19. IMPORT  S : SYSTEM,
  20.         O : OberonLib,
  21.         E : Exec,
  22.         I : Intuition,
  23.         G : Graphics,
  24.         GT: GadTools,
  25.         U : Utility,
  26.         EL: ExecLists ;
  27.  
  28. TYPE  WinPtr* = POINTER TO Win;
  29.       Win = RECORD (EL.Node)
  30.               s           : I.ScreenPtr ;
  31.               pubLocked   : BOOLEAN ;
  32.               vInfo       : GT.VisualInfo ;
  33.               w           : I.WindowPtr ;
  34.               first       : I.GadgetPtr ;
  35.               last        : I.GadgetPtr ;
  36.               firstToAdd  : I.GadgetPtr ;
  37.               newG        : GT.NewGadget ;
  38.               waitForDo   : BOOLEAN ;
  39.               newMenus    : POINTER TO ARRAY 1024 OF GT.NewMenu ;
  40.               firstFree   : INTEGER ;
  41.               lastFree    : INTEGER ;
  42.               endSet      : BOOLEAN ;
  43.               menu        : I.MenuPtr ;
  44.             END ;
  45.  
  46. CONST center*     = LONGSET{GT.placeTextIn} ;     (* use for NewGadget.textpos *)
  47.       right*      = LONGSET{GT.placeTextRight} ;
  48.       left*       = LONGSET{GT.placeTextLeft} ;
  49.       above*      = LONGSET{GT.placeTextAbove} ; top*   = above ;
  50.       below*      = LONGSET{GT.placeTextBelow} ; down*  = below ;
  51.       highlight*  = LONGSET{GT.highLabel} ;
  52.  
  53.       uChar*  = ORD("_") ;                            (* use for GT.underscore *)
  54.  
  55.       allIDCMP* = LONGSET{I.gadgetUp,I.gadgetDown,I.mouseMove,
  56.                           I.mouseButtons,I.intuiTicks} ;
  57.  
  58. TYPE  labels1*  = ARRAY 2 OF S.ADDRESS ;
  59.       labels2*  = ARRAY 3 OF S.ADDRESS ; (* use with cycle and mx gadgets to   *)
  60.       labels3*  = ARRAY 4 OF S.ADDRESS ; (* create the labels constants:       *)
  61.       labels4*  = ARRAY 5 OF S.ADDRESS ; (* GA.cyLabels,labels2(S.ADR("one"),  *)
  62.       labels5*  = ARRAY 6 OF S.ADDRESS ; (*                     S.ADR("two"),  *)
  63.       labels6*  = ARRAY 7 OF S.ADDRESS ; (*                     NIL) ;         *)
  64.       labels7*  = ARRAY 8 OF S.ADDRESS ;
  65.       labels8*  = ARRAY 9 OF S.ADDRESS ;
  66.       labels9*  = ARRAY 10 OF S.ADDRESS ;
  67.       labels10* = ARRAY 11 OF S.ADDRESS ;          (* I'm shure this is enough *)
  68.  
  69. CONST none* = LONGSET{} ;                  (* use for MenuSubItem mExclude *)
  70.       mxChecked* = {I.checkIt,I.checked};  (* use the following for Item and *)
  71.       mx* = {I.checkIt};                   (* SubItem flags *)
  72.       toggleChecked* = {I.checkIt,I.menuToggle,I.checked};
  73.       toggle* = {I.checkIt,I.menuToggle};
  74.  
  75.  
  76. VAR winList   : EL.List ;
  77.     win       : WinPtr ;     (* grrrr! *)
  78.     int       : I.IntuitionBasePtr ;
  79.  
  80. (* sorry *)
  81. PROCEDURE LockPubScreen{int,-510}(name{8}   : S.ADDRESS): I.ScreenPtr ;
  82. PROCEDURE UnlockPubScreen{int,-516}(name{8}   : S.ADDRESS ;
  83.                                     screen{9} : I.ScreenPtr) ;
  84.  
  85. (* call this before using any of the other routines and again after *)
  86. (* a call to Intuition.OpenWindow ! *)
  87. PROCEDURE Init*(VAR win : WinPtr ;
  88.                 VAR s   : I.ScreenPtr ;
  89.                     w   : I.WindowPtr): BOOLEAN ;
  90. BEGIN
  91.   IF win#NIL THEN
  92.     IF    (win.w=NIL) AND (w#NIL) THEN                 (* if window was opened *)
  93.       win.w:=w ;
  94.       IF win.firstToAdd#win.first THEN      (* gadtools make their own refresh *)
  95.         GT.RefreshWindow(win.w,NIL) ;
  96.       END ;
  97.     ELSIF (win.w#NIL) AND (w=NIL) THEN                 (* if window was closed *)
  98.       win.firstToAdd:=win.first ;
  99.     ELSE
  100.       RETURN FALSE ;                           (* what the hell should we do ? *)
  101.     END ;
  102.   ELSE
  103.     NEW(win) ; IF win=NIL THEN RETURN FALSE END ;
  104.     IF s=NIL THEN win.s:=LockPubScreen(NIL) ; win.pubLocked:=TRUE
  105.              ELSE win.s:=s
  106.     END ;
  107.     win.vInfo:=GT.GetVisualInfo(win.s,U.done) ;
  108.     IF win.vInfo=NIL THEN
  109.       DISPOSE(win) ; IF win.pubLocked THEN UnlockPubScreen(NIL,win.s) END ;
  110.       RETURN FALSE
  111.     END ;
  112.     win.first:=GT.CreateContext(win.last) ;
  113.     IF win.first=NIL THEN
  114.       GT.FreeVisualInfo(win.vInfo) ; DISPOSE(win) ;
  115.       IF win.pubLocked THEN UnlockPubScreen(NIL,win.s) END ; RETURN FALSE
  116.     END ;
  117.     win.w:=w ; win.firstToAdd:=win.first ;
  118.     EL.AddHead(winList,win) ;
  119.   END ;
  120.   RETURN TRUE ;
  121. END Init;
  122.  
  123. PROCEDURE Dispose*(VAR  win : WinPtr) ;
  124. BEGIN
  125.   IF win=NIL THEN RETURN END ;
  126.   EL.Remove(win) ;                                        (* closedown win *)
  127.   GT.FreeGadgets(win.first) ;
  128.   IF win.menu#NIL THEN GT.FreeMenus(win.menu) END ;
  129.   IF win.newMenus#NIL THEN DISPOSE(win.newMenus) END ;
  130.   GT.FreeVisualInfo(win.vInfo) ;
  131.   IF win.pubLocked THEN UnlockPubScreen(NIL,win.s) END ;
  132.   DISPOSE(win) ;
  133. END Dispose ;
  134.  
  135.  
  136.  
  137. (********************************************************************************)
  138. (************************* NewGadget fill routines ******************************)
  139. (* one of these two procedures is to be called before each call to CreateGadget *)
  140. (* I thought about including this into CreateGadget, but I meant this would *)
  141. (* be better *)
  142. PROCEDURE SpecialNewGadget*(win           : WinPtr ;
  143.                             le,te,wi,he   : INTEGER ;
  144.                             text          : S.ADDRESS ;
  145.                             textpos       : LONGSET ;
  146.                             font          : G.TextAttrPtr ;
  147.                             id            : INTEGER) ;
  148. BEGIN
  149.   IF win=NIL THEN RETURN END ;
  150.   win.newG.leftEdge:=le ; win.newG.topEdge:=te ;
  151.   win.newG.width:=wi ; win.newG.height:=he ;
  152.   win.newG.gadgetText:=text ;
  153.   win.newG.flags:=textpos ;
  154.   win.newG.gadgetID:=id ;
  155.   win.newG.visualInfo:=win.vInfo ;
  156.   IF font=NIL THEN win.newG.textAttr:=win.s.font
  157.               ELSE win.newG.textAttr:=font ;
  158.   END ;
  159. END SpecialNewGadget ;
  160.  
  161. (* $CopyArrays- *)
  162. PROCEDURE NewGadget*(win           : WinPtr ;
  163.                      le,te,wi,he   : INTEGER ;
  164.                      text          : ARRAY OF CHAR ;
  165.                      textpos       : LONGSET ;
  166.                      id            : INTEGER) ;
  167. BEGIN
  168.   IF text="" THEN SpecialNewGadget(win,le,te,wi,he,NIL,textpos,NIL,id)
  169.              ELSE SpecialNewGadget(win,le,te,wi,he,S.ADR(text),textpos,NIL,id)
  170.   END ;
  171. END NewGadget ;
  172.  
  173.  
  174.  
  175. (********************************************************************************)
  176. (************************* Gadget creation routines *****************************)
  177. (* add all gadgets to be added *)
  178. PROCEDURE AddGadgets(win    : WinPtr) ;
  179. BEGIN
  180.   IF win.firstToAdd#NIL THEN
  181.     IF I.AddGList(win.w,win.firstToAdd,-1,-1,NIL)=0 THEN END ;
  182.     I.RefreshGList(win.firstToAdd,win.w,NIL,-1) ;
  183.     win.firstToAdd:=NIL ; win.waitForDo:=FALSE ;
  184.     GT.RefreshWindow(win.w,NIL) ;
  185.   END ;
  186. END AddGadgets ;
  187.  
  188. (* Sorry for the taglist handling *)
  189. PROCEDURE CreateGadget*{"GadToolsSupport.CG"}(win{8}      : WinPtr ;
  190.                                       kind{0}     : LONGINT ;
  191.                                       tag1{10}..  : U.Tag
  192.                                      ): I.GadgetPtr ;
  193. PROCEDURE CreateGadgetA*{"GadToolsSupport.CG"}(win{8}     : WinPtr ;
  194.                                        kind{0}    : LONGINT ;
  195.                                        tag1{10}   : ARRAY OF U.TagItem
  196.                                       ): I.GadgetPtr ;
  197. PROCEDURE CG*(win{8}  : WinPtr ;
  198.               kind{0} : LONGINT ;
  199.               tag{10} : U.TagItemPtr
  200.              ): I.GadgetPtr ;
  201. VAR g : I.GadgetPtr ;
  202. BEGIN
  203.   IF win=NIL THEN RETURN NIL END ;
  204.   g:=GT.CreateGadgetA(kind,win.last,win.newG,S.VAL(U.Tags1,tag^)) ;
  205.   IF g#NIL THEN
  206.    (* GadTools for many gadgettypes creates a group of gadgets, returning *)
  207.    (* only the last one. Therefore we need to save the pointer to the first *)
  208.    (* because of Remove having to remove and free the whole group ! *)
  209.     g.userData:=win.last.nextGadget ;       (* first of group *)
  210.     IF win.firstToAdd=NIL THEN
  211.       win.firstToAdd:=win.last.nextGadget ;
  212.       win.last.nextGadget:=NIL ;            (* avoid recursieve add *)
  213.     END ;
  214.     win.last:=g ;
  215.     IF NOT win.waitForDo THEN AddGadgets(win) END ;
  216.   END ;
  217.   RETURN g ;
  218. END CG ;
  219.  
  220. (* use these procedures instead of orginal gadtools *)
  221. PROCEDURE SetGadgetAttrs*{"GadToolsSupport.SGA"}(win{8}     : WinPtr ;
  222.                                          gadget{9}  : I.GadgetPtr ;
  223.                                          tag1{10}.. : U.Tag) ;
  224. PROCEDURE SetGadgetAttrsA*{"GadToolsSupport.SGA"}(win{8}     : WinPtr ;
  225.                                           gadget{9}  : I.GadgetPtr ;
  226.                                           tag1{10}   : ARRAY OF U.TagItem) ;
  227. PROCEDURE SGA*(win{8}     : WinPtr ;
  228.                gadget{9}  : I.GadgetPtr ;
  229.                tag{10}    : U.TagItemPtr) ;
  230. BEGIN
  231.   IF (win=NIL) OR (win.w=NIL) OR (gadget=NIL) THEN RETURN END ;
  232.   IF win.firstToAdd#NIL THEN AddGadgets(win) END ;
  233.   GT.SetGadgetAttrsA(gadget^,win.w,NIL,S.VAL(U.Tags1,tag^)) ;
  234. END SGA ;
  235.  
  236. (* remove gadget group from intuition-list (not from display !) and free *)
  237. (* its' mem                                                              *)
  238. PROCEDURE RemoveGadget*(win         : WinPtr ;
  239.                         gad         : I.GadgetPtr) ;
  240. VAR g   : I.GadgetPtr ;
  241.     cnt : LONGINT ;
  242. BEGIN
  243.   IF (win=NIL) OR (gad.userData=NIL) THEN RETURN END ;       (* not our gadget *)
  244.   IF win.waitForDo THEN AddGadgets(win) END ;
  245.   cnt:=1 ;
  246.   IF gad.userData#gad THEN
  247.     g:=gad.userData ;
  248.     WHILE g#gad DO             (* we are private owner, so no forbid necessary *)
  249.       INC(cnt) ; g:=g.nextGadget ;
  250.     END ;
  251.   END ;
  252.   IF I.RemoveGList(win.w,gad.userData,cnt)=0 THEN END ;
  253.   gad.nextGadget:=NIL ; GT.FreeGadgets(gad.userData) ;
  254. END RemoveGadget ;
  255.  
  256.  
  257. PROCEDURE DrawBevelBox*{"GadToolsSupport.DBB"}(win{8}             : WinPtr;
  258.                                                left{0},top{1}     : LONGINT;
  259.                                                width{2},height{3} : LONGINT;
  260.                                                tag{9}..           : U.Tag) ;
  261. PROCEDURE DrawBevelBoxA*{"GadToolsSupport.DBB"}(win{8}            : WinPtr;
  262.                                                 left{0},top{1}    : LONGINT;
  263.                                                 width{2},height{3}: LONGINT;
  264.                                                 taglist{9}        : ARRAY OF U.TagItem) ;
  265. PROCEDURE DBB*(win{8}            : WinPtr;
  266.                left{0},top{1}    : LONGINT;
  267.                width{2},height{3}: LONGINT;
  268.                taglist{9}        : U.TagItemPtr) ;
  269. BEGIN
  270.   GT.DrawBevelBoxA(win.w.rPort,left,top,width,height,S.VAL(U.Tags1,taglist^)) ;
  271. END DBB ;
  272.  
  273.  
  274. (********************************************************************************)
  275. (*************************** User support routines ******************************)
  276. (* do not add the gadgets yet, but wait for a Do call *)
  277. PROCEDURE WaitForDo*(win  : WinPtr) ;
  278. BEGIN
  279.   IF win=NIL THEN RETURN END ;
  280.   win.waitForDo:=TRUE ;
  281. END WaitForDo ;
  282.  
  283. (* add and refresh all gadgets added since WaitForDo *)
  284. PROCEDURE Do*(win : WinPtr) ;
  285. BEGIN
  286.   IF win=NIL THEN RETURN END ;
  287.   AddGadgets(win) ;
  288. END Do ;
  289.  
  290. (* the following proc is to get the newwindow.firstGadget pointer *)
  291. (* therefore it makes no sense to use this with the window open *)
  292. PROCEDURE FirstGadget*(win  : WinPtr): I.GadgetPtr ;
  293. VAR g : I.GadgetPtr ;
  294. BEGIN
  295.   IF (win=NIL) OR (win.w#NIL) THEN RETURN NIL END ;
  296.   g:=win.firstToAdd ; win.firstToAdd:=NIL ;
  297.   win.waitForDo:=FALSE ;
  298.   RETURN g ;
  299. END FirstGadget ;
  300.  
  301. PROCEDURE VInfo*(win  : WinPtr): GT.VisualInfo ;
  302. BEGIN
  303.   IF win=NIL THEN RETURN NIL
  304.              ELSE RETURN win.vInfo
  305.   END ;
  306. END VInfo ;
  307.  
  308. PROCEDURE GetString*(    gad  : I.GadgetPtr ;
  309.                      VAR str  : ARRAY OF CHAR) ;
  310. BEGIN
  311.   COPY(gad.specialInfo(I.StringInfo).buffer^,str) ;
  312. END GetString ;
  313.  
  314. PROCEDURE GetNumber*(gad  : I.GadgetPtr): LONGINT ;
  315. BEGIN
  316.   RETURN gad.specialInfo(I.StringInfo).longInt ;
  317. END GetNumber ;
  318.  
  319.  
  320. (********************************************************************************)
  321. (*************************** Menu support routines ******************************)
  322. PROCEDURE AllocMenuSpace(win   : WinPtr;
  323.                          count : INTEGER;
  324.                          new   : BOOLEAN) ;
  325. VAR newM  : POINTER TO ARRAY 1 OF GT.NewMenu ;
  326. BEGIN
  327.   O.New(newM,(count+1)*S.SIZE(GT.NewMenu)) ;
  328.   IF new AND (win.newMenus#NIL) THEN
  329.     DISPOSE(win.newMenus) ;
  330.     win.firstFree:=0 ; win.endSet:=FALSE ;
  331.   END ;
  332.   IF win.newMenus#NIL THEN
  333.     E.CopyMem(win.newMenus[0],newM[0],(win.lastFree+1)*S.SIZE(GT.NewMenu)) ;
  334.   END ;
  335.   win.newMenus:=S.VAL(S.ADDRESS,newM) ; win.lastFree:=count ;
  336. END AllocMenuSpace ;
  337.  
  338. PROCEDURE BeginMenus*(win   : WinPtr) ;
  339. BEGIN
  340.   AllocMenuSpace(win,20,TRUE) ;
  341. END BeginMenus ;
  342.  
  343. (* $CopyArrays- *)
  344. PROCEDURE NewMenu*(win      : WinPtr ;
  345.                    type     : SHORTINT ;
  346.                    label    : S.ADDRESS ;
  347.                    commKey  : ARRAY OF CHAR ;
  348.                    flags    : SET ;
  349.                    mExclude : LONGSET ;
  350.                    uData    : S.ADDRESS) ;
  351. BEGIN
  352.   IF win.firstFree=win.lastFree THEN AllocMenuSpace(win,win.lastFree+10,FALSE) END ;
  353.   IF win.endSet THEN DEC(win.firstFree) END ;
  354.  
  355.   win.newMenus[win.firstFree].type:=type ;
  356.   win.newMenus[win.firstFree].label:=label ;
  357.   IF commKey#"" THEN win.newMenus[win.firstFree].commKey:=S.ADR(commKey) ;
  358.                 ELSE win.newMenus[win.firstFree].commKey:=NIL ;
  359.   END ;
  360.   win.newMenus[win.firstFree].flags:=flags ;
  361.   win.newMenus[win.firstFree].mutualExclude:=mExclude ;
  362.   win.newMenus[win.firstFree].userData:=uData ;
  363.   INC(win.firstFree) ;
  364. END NewMenu ;
  365.  
  366. (* $CopyArrays- *)
  367. PROCEDURE MenuTitle*(win      : WinPtr ;
  368.                      label    : ARRAY OF CHAR ;
  369.                      enabled  : BOOLEAN) ;
  370. BEGIN
  371.   IF enabled THEN NewMenu(win,GT.title,S.ADR(label),"",{},LONGSET{},NIL) ;
  372.              ELSE NewMenu(win,GT.title,S.ADR(label),"",{GT.menuDisabled},LONGSET{},NIL) ;
  373.   END ;
  374. END MenuTitle ;
  375.  
  376. (* $CopyArrays- *)
  377. PROCEDURE MenuItem*(win     : WinPtr ;
  378.                     label   : ARRAY OF CHAR ;
  379.                     commKey : ARRAY OF CHAR ;
  380.                     flags   : SET) ;
  381. BEGIN
  382.   NewMenu(win,GT.item,S.ADR(label),commKey,flags,LONGSET{},NIL) ;
  383. END MenuItem ;
  384.  
  385. PROCEDURE MenuItemBar*(win : WinPtr) ;
  386. BEGIN
  387.   NewMenu(win,GT.item,GT.barLabel,"",{},LONGSET{},NIL) ;
  388. END MenuItemBar ;
  389.  
  390. (* $CopyArrays- *)
  391. PROCEDURE MenuSubItem*(win      : WinPtr ;
  392.                        label    : ARRAY OF CHAR ;
  393.                        commKey  : ARRAY OF CHAR ;
  394.                        flags    : SET ;
  395.                        mExclude : LONGSET) ;
  396. BEGIN
  397.   NewMenu(win,GT.sub,S.ADR(label),commKey,flags,mExclude,NIL) ;
  398. END MenuSubItem ;
  399.  
  400. PROCEDURE DoMenus*(win    : WinPtr ;
  401.                    color  : INTEGER): BOOLEAN ;
  402. BEGIN
  403.   IF (win.w=NIL) OR (win.newMenus=NIL) OR (win.firstFree=0) THEN RETURN FALSE END ;
  404.   IF ~win.endSet THEN
  405.     NewMenu(win,GT.end,NIL,"",{},LONGSET{},NIL) ;
  406.     win.endSet:=TRUE ;
  407.   END ;
  408.   IF win.menu#NIL THEN
  409.     I.ClearMenuStrip(win.w) ; GT.FreeMenus(win.menu) ; win.menu:=NIL ;
  410.   END ;
  411.   win.menu:=GT.CreateMenus(win.newMenus^,GT.mnFrontPen,color,U.done) ;
  412.   IF win.menu=NIL THEN RETURN FALSE END ;
  413.   IF ~GT.LayoutMenus(win.menu,win.vInfo,U.done) THEN
  414.     GT.FreeMenus(win.menu) ; win.menu:=NIL ; RETURN FALSE ;
  415.   END ;
  416.   RETURN I.SetMenuStrip(win.w,win.menu^) ;
  417. END DoMenus ;
  418.  
  419. PROCEDURE GetMenuAdr*(win : WinPtr): I.MenuPtr ;
  420. BEGIN
  421.   RETURN win.menu ;
  422. END GetMenuAdr ;
  423.  
  424. PROCEDURE NextSelected*(win   : WinPtr ;
  425.                         code  : INTEGER): INTEGER ;
  426. VAR item  : I.MenuItemPtr ;
  427. BEGIN
  428.   item:=I.ItemAddress(win.menu^,code) ;
  429.   RETURN item.nextSelect ;
  430. END NextSelected ;
  431.  
  432. BEGIN
  433.   int:=I.int ;
  434.   EL.Init(winList) ;
  435. CLOSE
  436.   WHILE NOT EL.Empty(winList) DO
  437.     win:=S.VAL(WinPtr,EL.Head(winList)) ;  (* Dispose removes win from list ! *)
  438.     Dispose(win) ;
  439.   END ;
  440. END GadToolsSupport.
  441.